home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / tcl-util.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-14  |  12.2 KB  |  504 lines
  1. /*
  2.  *
  3.  * t c l - u t i l . c        -- Some Tcl utilities (this correpond to part 
  4.  *                    of code of the Tcl lib modified to take into
  5.  *                   account some Scheme specificities)
  6.  *
  7.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  8.  * 
  9.  *
  10.  * Permission to use, copy, and/or distribute this software and its
  11.  * documentation for any purpose and without fee is hereby granted, provided
  12.  * that both the above copyright notice and this permission notice appear in
  13.  * all copies and derived works.  Fees for distribution or use of this
  14.  * software or derived works may only be charged with express written
  15.  * permission of the copyright holder.  
  16.  * This software is provided ``as is'' without express or implied warranty.
  17.  *
  18.  * This software is a derivative work of other copyrighted softwares; the
  19.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  20.  *
  21.  *
  22.  *           Author: Erick Gallesio [eg@unice.fr]
  23.  *    Creation date: 26-Feb-1993 10:10
  24.  * Last file update: 14-Jul-1996 21:58
  25.  *
  26.  *
  27.  * This code is derivated from several Tcl files which have the following 
  28.  * copyright notice
  29.  *
  30.  * Copyright (c) 1990-1993 The Regents of the University of California.
  31.  * Copyright (c) 1994 Sun Microsystems, Inc.
  32.  *
  33.  * See the file "license.terms" for information on usage and redistribution
  34.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  35.  */
  36.  
  37. #include "stk.h"
  38. #ifndef WIN32
  39. #  include <tclInt.h>
  40. #  include <tclPort.h>
  41. #endif
  42.  
  43.  
  44. /*
  45.  *----------------------------------------------------------------------
  46.  *
  47.  * Tcl_PosixError --
  48.  *
  49.  *    This procedure is typically called after UNIX kernel calls
  50.  *    return errors.  It stores machine-readable information about
  51.  *    the error in $errorCode returns an information string for
  52.  *    the caller's use.
  53.  *
  54.  * Results:
  55.  *    The return value is a human-readable string describing the
  56.  *    error, as returned by strerror.
  57.  *
  58.  * Side effects:
  59.  *    The global variable $errorCode is reset.
  60.  *
  61.  *----------------------------------------------------------------------
  62.  */
  63.  
  64. char *
  65. Tcl_PosixError(interp)
  66.     Tcl_Interp *interp;        /* Interpreter whose $errorCode variable
  67.                  * is to be changed. */
  68. {
  69. #ifdef STk_CODE
  70.     return (char *) strerror(errno);
  71. #else
  72.     char *id, *msg;
  73.  
  74.     id = Tcl_ErrnoId();
  75.     msg = strerror(errno);
  76.     Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
  77.     return msg;
  78. #endif
  79. }
  80.  
  81. /*
  82.  *----------------------------------------------------------------------
  83.  *
  84.  * Tcl_Backslash --
  85.  *
  86.  *    Figure out how to handle a backslash sequence.
  87.  *
  88.  * Results:
  89.  *    The return value is the character that should be substituted
  90.  *    in place of the backslash sequence that starts at src.  If
  91.  *    readPtr isn't NULL then it is filled in with a count of the
  92.  *    number of characters in the backslash sequence.
  93.  *
  94.  * Side effects:
  95.  *    None.
  96.  *
  97.  *----------------------------------------------------------------------
  98.  */
  99.  
  100. char
  101. Tcl_Backslash(src, readPtr)
  102.     char *src;            /* Points to the backslash character of
  103.                  * a backslash sequence. */
  104.     int *readPtr;        /* Fill in with number of characters read
  105.                  * from src, unless NULL. */
  106. {
  107.     register char *p = src+1;
  108.     char result;
  109.     int count;
  110.  
  111.     count = 2;
  112.  
  113.     switch (*p) {
  114.     case 'a':
  115.         result = 0x7;    /* Don't say '\a' here, since some compilers */
  116.         break;        /* don't support it. */
  117.     case 'b':
  118.         result = '\b';
  119.         break;
  120.     case 'f':
  121.         result = '\f';
  122.         break;
  123.     case 'n':
  124.         result = '\n';
  125.         break;
  126.     case 'r':
  127.         result = '\r';
  128.         break;
  129.     case 't':
  130.         result = '\t';
  131.         break;
  132.     case 'v':
  133.         result = '\v';
  134.         break;
  135.     case 'x':
  136.         if (isxdigit(UCHAR(p[1]))) {
  137.         char *end;
  138.  
  139.         result = strtoul(p+1, &end, 16);
  140.         count = end - src;
  141.         } else {
  142.         count = 2;
  143.         result = 'x';
  144.         }
  145.         break;
  146.     case '\n':
  147.         do {
  148.         p++;
  149.         } while (isspace(UCHAR(*p)));
  150.         result = ' ';
  151.         count = p - src;
  152.         break;
  153.     case 0:
  154.         result = '\\';
  155.         count = 1;
  156.         break;
  157.     default:
  158.         if (isdigit(UCHAR(*p))) {
  159.         result = *p - '0';
  160.         p++;
  161.         if (!isdigit(UCHAR(*p))) {
  162.             break;
  163.         }
  164.         count = 3;
  165.         result = (result << 3) + (*p - '0');
  166.         p++;
  167.         if (!isdigit(UCHAR(*p))) {
  168.             break;
  169.         }
  170.         count = 4;
  171.         result = (result << 3) + (*p - '0');
  172.         break;
  173.         }
  174.         result = *p;
  175.         count = 2;
  176.         break;
  177.     }
  178.  
  179.     if (readPtr != NULL) {
  180.     *readPtr = count;
  181.     }
  182.     return result;
  183. }
  184.  
  185. /*
  186.  *----------------------------------------------------------------------
  187.  *
  188.  * Tcl_TildeSubst --
  189.  *
  190.  *    Given a name starting with a tilde, produce a name where
  191.  *    the tilde and following characters have been replaced by
  192.  *    the home directory location for the named user.
  193.  *
  194.  * Results:
  195.  *    The result is a pointer to a static string containing
  196.  *    the new name.  If there was an error in processing the
  197.  *    tilde, then an error message is left in interp->result
  198.  *    and the return value is NULL.  The result may be stored
  199.  *    in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr)
  200.  *    to free the name.
  201.  *
  202.  * Side effects:
  203.  *    Information may be left in bufferPtr.
  204.  *
  205.  *----------------------------------------------------------------------
  206.  */
  207. char *
  208. Tcl_TildeSubst(interp, name, bufferPtr)
  209.     Tcl_Interp *interp;        /* Interpreter in which to store error
  210.                  * message (if necessary). */
  211.     char *name;            /* File name, which may begin with "~/"
  212.                  * (to indicate current user's home directory)
  213.                  * or "~<user>/" (to indicate any user's
  214.                  * home directory). */
  215.     Tcl_DString *bufferPtr;    /* May be used to hold result.  Must not hold
  216.                  * anything at the time of the call, and need
  217.                  * not even be initialized. */
  218. {
  219.     char *dir;
  220.     register char *p;
  221.  
  222.     Tcl_DStringInit(bufferPtr);
  223.     if (name[0] != '~') {
  224.     return name;
  225.     }
  226.  
  227.     if ((name[1] == '/') || (name[1] == '\0')) {
  228.     dir = getenv("HOME");
  229.     if (dir == NULL) {
  230.         Tcl_ResetResult(interp);
  231.         Tcl_AppendResult(interp, "couldn't find HOME environment ",
  232.             "variable to expand \"", name, "\"", (char *) NULL);
  233.         return NULL;
  234.     }
  235.     Tcl_DStringAppend(bufferPtr, dir, -1);
  236.     Tcl_DStringAppend(bufferPtr, name+1, -1);
  237.     } else {
  238.     struct passwd *pwPtr;
  239.  
  240.     for (p = &name[1]; (*p != 0) && (*p != '/'); p++) {
  241.         /* Null body;  just find end of name. */
  242.     }
  243.     Tcl_DStringAppend(bufferPtr, name+1, p - (name+1));
  244. #ifdef WIN32
  245.     Tcl_ResetResult(interp);
  246.     Tcl_AppendResult(interp, "user \"", bufferPtr->string,
  247.             "\" doesn't exist", (char *) NULL);
  248.     return NULL;
  249.     }
  250. #else
  251.     pwPtr = getpwnam(bufferPtr->string);
  252.     if (pwPtr == NULL) {
  253.         endpwent();
  254.         Tcl_ResetResult(interp);
  255.         Tcl_AppendResult(interp, "user \"", bufferPtr->string,
  256.             "\" doesn't exist", (char *) NULL);
  257.         return NULL;
  258.     }
  259.     Tcl_DStringFree(bufferPtr);
  260.     Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1);
  261.     Tcl_DStringAppend(bufferPtr, p, -1);
  262.     endpwent();
  263.     }
  264.     return bufferPtr->string;
  265. #endif
  266. }
  267.  
  268.  
  269. int Tcl_ExprDouble(interp, string, ptr)
  270.      Tcl_Interp *interp;        /* Context in which to evaluate the
  271.                      * expression. */
  272.      char *string;            /* Expression to evaluate. */
  273.      double *ptr;            /* Where to store result. */
  274. {
  275.   SCM value = STk_eval_C_string(string, NIL);
  276.  
  277.   if (value) {
  278.     if (NUMBERP(value)) {
  279.       *ptr = FLONM(STk_exact2inexact(value));
  280.       return TCL_OK;
  281.     }
  282.   }
  283.   interp->result = "expression didn't have numeric value";
  284.   return TCL_ERROR;
  285. }
  286.  
  287.  
  288. int Tcl_ExprLong(interp, string, ptr)
  289.      Tcl_Interp *interp;        /* Context in which to evaluate the
  290.                      * expression. */
  291.      char *string;            /* Expression to evaluate. */
  292.      long *ptr;                /* Where to store result. */
  293. {
  294.   SCM value = STk_eval_C_string(string, NIL);
  295.  
  296.   if (value) {
  297.     if (EXACTP(value)) {
  298.       *ptr = (long) FLONM(STk_exact2inexact(value));
  299.       return TCL_OK;
  300.     }
  301.   }
  302.   interp->result = "expression didn't have numeric value";
  303.   return TCL_ERROR;
  304. }
  305.  
  306.  
  307. void Tcl_AddErrorInfo(interp, message)
  308.      Tcl_Interp *interp;
  309.      char *message;    
  310. {
  311.   SCM new, old, error_info;
  312.   
  313.   error_info = Intern("*error-info*");
  314.   new        = STk_makestring(message);
  315.   old         = VCELL(error_info);
  316.  
  317.   if (!STRINGP(old)) old = STk_makestring("");
  318.     
  319.   /* Append message to current value of *error-info* */
  320.   VCELL(error_info) = STk_string_append(LIST2(old, new), 2);             
  321. }
  322.  
  323. /*
  324.  *----------------------------------------------------------------------
  325.  *
  326.  * Tcl_AllowExceptions --
  327.  *
  328.  *    Sets a flag in an interpreter so that exceptions can occur
  329.  *    in the next call to Tcl_Eval without them being turned into
  330.  *    errors.
  331.  *
  332.  * Results:
  333.  *    None.
  334.  *
  335.  * Side effects:
  336.  *    The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
  337.  *    evalFlags structure.  See the reference documentation for
  338.  *    more details.
  339.  *
  340.  *----------------------------------------------------------------------
  341.  */
  342.  
  343. void
  344. Tcl_AllowExceptions(interp)
  345.     Tcl_Interp *interp;        /* Interpreter in which to set flag. */
  346. {
  347.     Interp *iPtr = (Interp *) interp;
  348.  
  349.     iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
  350. }
  351.  
  352. #ifdef USE_TK
  353.  
  354. /*
  355.  *=============================================================================
  356.  *
  357.  * Misc
  358.  *
  359.  *=============================================================================
  360.  */
  361.  
  362. /*
  363.  * The FileHashKey structure is used to associate the OS file handle and type
  364.  * with the corresponding notifier data in a FileHandle.
  365.  */
  366.  
  367. typedef struct FileHashKey {
  368.     int type;            /* File handle type. */
  369.     ClientData osHandle;    /* Platform specific OS file handle. */
  370. } FileHashKey;
  371.  
  372. typedef struct FileHandle {
  373.     FileHashKey key;        /* Hash key for a given file. */
  374.     ClientData data;        /* Platform specific notifier data. */
  375.     Tcl_FileFreeProc *proc;    /* Callback to invoke when file is freed. */
  376. } FileHandle;
  377.  
  378. /*
  379.  * Static variables used in this file:
  380.  */
  381.  
  382. static Tcl_HashTable fileTable;    /* Hash table containing file handles. */
  383. static int initialized = 0;    /* 1 if this module has been initialized. */
  384.  
  385. /*
  386.  * Static procedures used in this file:
  387.  */
  388.  
  389. static void         FileExitProc _ANSI_ARGS_((ClientData clientData));
  390.  
  391. /*
  392.  *----------------------------------------------------------------------
  393.  *
  394.  * Tcl_GetFile --
  395.  *
  396.  *    This function retrieves the file handle associated with a
  397.  *    platform specific file handle of the given type.  It creates
  398.  *    a new file handle if needed.
  399.  *
  400.  * Results:
  401.  *    Returns the file handle associated with the file descriptor.
  402.  *
  403.  * Side effects:
  404.  *    Initializes the file handle table if necessary.
  405.  *
  406.  *----------------------------------------------------------------------
  407.  */
  408.  
  409. Tcl_File
  410. Tcl_GetFile(osHandle, type)
  411.     ClientData osHandle;    /* Platform specific file handle. */
  412.     int type;            /* Type of file handle. */
  413. {
  414.     FileHashKey key;
  415.     Tcl_HashEntry *entryPtr;
  416.     int new;
  417.  
  418.     if (!initialized) {
  419.     Tcl_InitHashTable(&fileTable, sizeof(FileHashKey)/sizeof(int));
  420.     Tcl_CreateExitHandler(FileExitProc, 0);
  421.     initialized = 1;
  422.     }
  423.     key.osHandle = osHandle;
  424.     key.type = type;
  425.     entryPtr = Tcl_CreateHashEntry(&fileTable, (char *) &key, &new);
  426.     if (new) {
  427.     FileHandle *newHandlePtr;
  428.  
  429.     newHandlePtr = (FileHandle *) ckalloc(sizeof(FileHandle));
  430.     newHandlePtr->key = key;
  431.     newHandlePtr->data = NULL;
  432.     newHandlePtr->proc = NULL;
  433.     Tcl_SetHashValue(entryPtr, newHandlePtr);
  434.     }
  435.     
  436.     return (Tcl_File) Tcl_GetHashValue(entryPtr);
  437. }
  438.  
  439. /*
  440.  *----------------------------------------------------------------------
  441.  *
  442.  * Tcl_GetFileInfo --
  443.  *
  444.  *    This function retrieves the platform specific file data and
  445.  *    type from the file handle.
  446.  *
  447.  * Results:
  448.  *    If typePtr is not NULL, sets *typePtr to the type of the file.
  449.  *    Returns the platform specific file data.
  450.  *
  451.  * Side effects:
  452.  *    None.
  453.  *
  454.  *----------------------------------------------------------------------
  455.  */
  456.  
  457. ClientData
  458. Tcl_GetFileInfo(handle, typePtr)
  459.     Tcl_File handle;
  460.     int *typePtr;
  461. {
  462.     FileHandle *handlePtr = (FileHandle *) handle;
  463.  
  464.     if (typePtr) {
  465.     *typePtr = handlePtr->key.type;
  466.     }
  467.     return handlePtr->key.osHandle;
  468. }
  469.  
  470. /*
  471.  *----------------------------------------------------------------------
  472.  *
  473.  * FileExitProc --
  474.  *
  475.  *    This function an exit handler that frees any memory allocated
  476.  *    for the file handle table.
  477.  *
  478.  * Results:
  479.  *    None.
  480.  *
  481.  * Side effects:
  482.  *    Cleans up the file handle table.
  483.  *
  484.  *----------------------------------------------------------------------
  485.  */
  486.  
  487. static void
  488. FileExitProc(clientData)
  489.     ClientData clientData;    /* Not used. */
  490. {
  491.     Tcl_HashSearch search;
  492.     Tcl_HashEntry *entryPtr;
  493.  
  494.     entryPtr = Tcl_FirstHashEntry(&fileTable, &search);
  495.  
  496.     while (entryPtr) {
  497.     ckfree(Tcl_GetHashValue(entryPtr));
  498.     entryPtr = Tcl_NextHashEntry(&search);
  499.     }
  500.  
  501.     Tcl_DeleteHashTable(&fileTable);
  502. }
  503. #endif
  504.